home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / textSelect.tcl.z / textSelect.tcl
Text File  |  2002-07-08  |  17KB  |  632 lines
  1. # textSelect.tcl
  2. #
  3. # Text selection support.
  4. # Borrowed from Jupitor code written by Dave Nichols.
  5. #
  6. # This is imported by the widgetText routines.
  7. #
  8. # Copyright (c) 1993 Xerox Corporation.
  9. # Use and copying of this software and preparation of derivative works based
  10. # upon this software are permitted. Any distribution of this software or
  11. # derivative works must comply with all applicable United States export
  12. # control laws. This software is made available AS IS, and Xerox Corporation
  13. # makes no warranty about the software, its performance or its conformity to
  14. # any specification.
  15.  
  16. #
  17. # Selections: making, claiming, and handling requests for.
  18. #
  19. proc Text_HandleSelRequest { w offset maxBytes } {
  20.     global tkPriv
  21.     if ![info exists tkPriv(lastsel)] {
  22.     return ""
  23.     }
  24.     return [string range $tkPriv(lastsel) $offset [expr {$offset+$maxBytes}]]
  25. }
  26.  
  27. proc Text_LoseSelection { w } {
  28.     $w tag remove sel 0.0 end
  29. }
  30.  
  31. proc Text_SelectTo {w index} {
  32.     global tkPriv
  33.  
  34.      if [catch {$w index anchor}] {
  35.     return
  36.      }
  37.     if ![info exists tkPriv(selectMode)] {
  38.     set tkPriv(selectMode) char
  39.     }
  40.     case $tkPriv(selectMode) {
  41.     char {
  42.         if [$w compare $index == anchor] {
  43.         set first $index
  44.         set last $index
  45.         } elseif [$w compare $index < anchor] {
  46.         set first $index
  47.         set last anchor
  48.         } else {
  49.         set first anchor
  50.         set last [$w index $index]
  51.         }
  52.     }
  53.     word {
  54.         if [$w compare $index < anchor] {
  55.         set first [$w index "$index wordstart"]
  56.         set last [$w index "anchor wordend"]
  57.         } else {
  58.         set first [$w index "anchor wordstart"]
  59.         set last [$w index "$index wordend"]
  60.         }
  61.     }
  62.     line {
  63.         if [$w compare $index < anchor] {
  64.         set first [$w index "$index linestart"]
  65.         set last [$w index "anchor lineend + 1c"]
  66.         } else {
  67.         set first [$w index "anchor linestart"]
  68.         set last [$w index "$index lineend + 1c"]
  69.         }
  70.     }
  71.     }
  72.     $w tag remove sel 0.0 $first
  73.     $w tag add sel $first $last
  74.     $w tag remove sel $last end
  75.     $w tag raise sel
  76. }
  77.  
  78. # Called when we're done doing a selection.
  79. proc Text_SelectionEnd { w rotate } {
  80.     global tkPriv
  81.     set sel ""
  82.     if {[catch {set sel [$w get sel.first sel.last]}]} {
  83.     return
  84.     }
  85.     set tkPriv(lastsel) $sel
  86.     selection own $w "Text_LoseSelection $w"
  87.     if {$rotate} { Text_CutRotate 1 }
  88.     cutbuffer set 0 $sel
  89. }
  90.  
  91. # The procedure below compares three indices, a, b, and c.  Index b must
  92. # be less than c.  The procedure returns 1 if a is closer to b than to c,
  93. # and 0 otherwise.  The "w" argument is the name of the text widget in
  94. # which to do the comparison.
  95. proc Text_IndexCloser {w a b c} {
  96.     set a [$w index $a]
  97.     set b [$w index $b]
  98.     set c [$w index $c]
  99.     if [$w compare $a <= $b] {
  100.     return 1
  101.     }
  102.     if [$w compare $a >= $c] {
  103.     return 0
  104.     }
  105.     scan $a "%d.%d" lineA chA
  106.     scan $b "%d.%d" lineB chB
  107.     scan $c "%d.%d" lineC chC
  108.     if {$chC == 0} {
  109.     incr lineC -1
  110.     set chC [string length [$w get $lineC.0 $lineC.end]]
  111.     }
  112.     if {$lineB != $lineC} {
  113.     return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
  114.     }
  115.     return [expr {($chA-$chB) < ($chC-$chA)}]
  116. }
  117.  
  118. # Start extending a selection.  Chooses the end farthest from the mouse hit.
  119. proc Text_StartExtend { w index } {
  120.     global tkPriv
  121.     set tkPriv(delstate) {}
  122.     if {[$w tag ranges sel] == ""} {
  123.     set tkPriv(selectMode) char
  124.     $w mark set anchor insert
  125.     } else {
  126.     if {[Text_IndexCloser $w $index sel.first sel.last]} {
  127.         $w mark set anchor sel.last
  128.     } else {
  129.         $w mark set anchor sel.first
  130.     }
  131.     $w mark set insert anchor
  132.     }
  133.     Text_SelectTo $w $index
  134.     if {[lindex [$w config -state] 4] == "normal"} {focus $w}
  135. }
  136.  
  137. # Return the current selection (from any window) or cut buffer 0.
  138. proc Text_Selection {} {
  139.     if [catch {selection get} sel] {
  140.     if [catch {selection get -selection CLIPBOARD} sel] {
  141.         if [catch {cutbuffer get 0} sel] {
  142.         return ""
  143.         }
  144.     }
  145.     }
  146.     return $sel
  147. }
  148.  
  149. #
  150. #
  151. #
  152.  
  153. proc Text_Delete {w start {end {}} {addkill 0}} {
  154.     global TextNames TextType tkPriv
  155.     if {![info exists TextType($w)]} {
  156.     set TextType($w) text
  157.     }
  158.     set st [$w index $start]
  159.     if {[string length $end] == 0} {
  160.     set e [$w index "$start + 1c"]
  161.     } else {
  162.     set e [$w index $end]
  163.     }
  164.     case $TextType($w) {
  165.     text {
  166.         if {[info exists TextNames($w)]} {
  167.         usertextdelete $TextNames($w) $st $e
  168.         }
  169.         Text_DoKill $w $st $e $addkill
  170.         $w delete $st $e
  171.     }
  172.     readonly {
  173.         return
  174.     }
  175.     typescript {
  176.         if {[$w compare $st < fence]} {
  177.         set st fence
  178.         }
  179.         if {[$w compare $e < fence]} {
  180.         set e fence
  181.         }
  182.         if {[$w compare insert < $st]} {
  183.         $w mark set insert $st
  184.         }
  185.         Text_DoKill $w $st $e $addkill
  186.         $w delete $st $e
  187.     }
  188.     }
  189. }
  190.  
  191. # Do kill buffer processing.  If addkill is true, then add to the kill ring
  192. # if the start or end point lines up with the old delete point.  Otherwise,
  193. # zap the delete point.
  194. proc Text_DoKill {w start end addkill} {
  195.     global tkPriv
  196.     if {! $addkill} {
  197.     set tkPriv(delstate) {}
  198.     return
  199.     }
  200.     if ![info exists tkPriv(delstate)] {
  201.     set tkPriv(delstate) {}
  202.     }
  203.     if [$w compare $start == $end] { return }
  204.     set text [$w get $start $end]
  205.     set oldwin [lindex $tkPriv(delstate) 0]
  206.     set oldmode [lindex $tkPriv(delstate) 1]
  207.     set oldpos [lindex $tkPriv(delstate) 2]
  208.     if {$oldwin != $w || $oldmode != "killing" || [string length $oldpos]==0} {
  209.     Text_CutRotate 1
  210.     set tkPriv(lastsel) $text
  211.     } elseif {[$w compare $start == $oldpos]} {
  212.     set tkPriv(lastsel) "$tkPriv(lastsel)$text"
  213.     } elseif {[$w compare $end == $oldpos]} {
  214.     set tkPriv(lastsel) "$text$tkPriv(lastsel)"
  215.     } else {
  216.     Text_CutRotate 1
  217.     set tkPriv(lastsel) $text
  218.     }
  219.     cutbuffer set 0 $tkPriv(lastsel)
  220.     catch {clipboard clear ; clipboard append $tkPriv(lastsel)}
  221.     selection own $w "Text_LoseSelection $w"
  222.     set tkPriv(delstate) "$w killing $start"
  223. }
  224.  
  225. proc Text_Insert {w place text {tags {}}} {
  226.     global TextNames TextType tkPriv
  227.     set tkPriv(delstate) {}
  228.     if {![info exists TextType($w)]} {
  229.     set TextType($w) text
  230.     }
  231.     set pl [$w index $place]
  232.     case $TextType($w) {
  233.     text {
  234.         if {[info exists TextNames($w)]} {
  235.         usertextinsert $TextNames($w) $pl $text
  236.         }
  237.         if {[string length $tags]} {
  238.         $w insert $pl $text $tags
  239.         } else {
  240.         $w insert $pl $text
  241.         }
  242.     }
  243.     readonly {
  244.         return
  245.     }
  246.     typescript {
  247.         # Insert at end if we're not the editable region.
  248.         if {[$w compare $place < fence]} {
  249.         $w mark set insert end
  250.         set place insert
  251.         }
  252.         # Trim at first newline (in case it's a paste).
  253.         if {[string first "\n" $text]} {
  254.         # Save part of input after cursor and glue it onto
  255.         # inserted text.
  256.         set saveText [$w get insert end]
  257.         Text_Delete $w insert end
  258.         } else {
  259.         set saveText ""
  260.         }
  261.         while {[string length $text] != 0} {
  262.         set firstNL [string first "\n" $text]
  263.         if {$firstNL != -1} {
  264.             set t [string range $text 0 [expr $firstNL-1]]
  265.             set text [string range $text [expr $firstNL+1] end]
  266.         } else {
  267.             set t $text
  268.             set text ""
  269.         }
  270.         set pl [$w index $place]
  271.         # Have to save and reset fence because marks end up at the
  272.         # end of inserted strings, and we want it at the beginning.
  273.         set f [$w index fence]
  274.         if {[string length $tags]} {
  275.             $w insert $pl $t $tags
  276.         } else {
  277.             $w insert $pl $t
  278.         }
  279.         $w mark set fence $f
  280.         if {$firstNL != -1} {
  281.             ts_SendLine $w
  282.         }
  283.         }
  284.         if {[string length $saveText] != 0} {
  285.         # Now paste back in the saved text such that the insert
  286.         # point ends up in the right place.
  287.         set f [$w index fence]
  288.         set i [$w index insert]
  289.         $w insert insert $saveText
  290.         $w mark set fence $f
  291.         $w mark set insert $i
  292.         }
  293.     }
  294.     }
  295. }
  296.  
  297. proc Text_Yank { w } {
  298.     global tkPriv sedit
  299.     set sel [Text_Selection]
  300.     if {[string length $sel] != 0} {
  301.     # check for 8bit characters in the selection
  302.     if [regexp "\[\x80-\xff\]" $sel] {
  303.         set sedit($w,8bit) 1
  304.     }
  305.     set start [$w index insert]
  306.     Text_Insert $w insert $sel
  307.     $w yview -pickplace insert
  308.     set end [$w index insert]
  309.     set tkPriv(delstate) "$w yank $start $end"
  310.     }
  311. }
  312.  
  313. proc Text_YankPop { w } {
  314.     global tkPriv
  315.     set oldwin [lindex $tkPriv(delstate) 0]
  316.     set oldmode [lindex $tkPriv(delstate) 1]
  317.     set oldstart [lindex $tkPriv(delstate) 2]
  318.     set oldend [lindex $tkPriv(delstate) 3]
  319.     if {$w != $oldwin || $oldmode != "yank" || [$w compare insert != $oldend]} {
  320.     set tkPriv(delstate) {}
  321.     return
  322.     }
  323.     Text_Delete $w $oldstart $oldend
  324.     Text_CutRotate -1
  325.     set start [$w index insert]
  326.     Text_Insert $w insert [cutbuffer get 0]
  327.     set end [$w index insert]
  328.     set tkPriv(delstate) "$w yank $start $end"
  329. }
  330.  
  331. proc Text_MoveInsert {w place {clear clear}} {
  332.     global tkPriv
  333.     set tkPriv(selectMode) char
  334.     set tkPriv(delstate) {}
  335.     global sedit
  336.     if {[string compare $clear "clear"] == 0 && $sedit(typeKillsSel)} {
  337.         $w tag remove sel 0.0 end
  338.     }
  339.     $w mark set insert $place
  340.     $w yview -pickplace insert
  341. }
  342.  
  343. proc Text_MoveToBOL {w} {
  344.     global TextType
  345.     if ![info exists TextType($w)] {
  346.     set TextType($w) text
  347.     }
  348.     if {$TextType($w) == "typescript" && [$w compare insert > fence]} {
  349.     Text_MoveInsert $w fence
  350.     } else {
  351.     Text_MoveInsert $w "insert linestart"
  352.     }
  353. }
  354.  
  355. proc Text_PrevWord {w index} {
  356.     set cur $index
  357.     while {[$w compare 1.0 < $cur]} {
  358.     set text [$w get "$cur linestart" $cur]
  359.     if {[regexp -indices {^(|.*[^a-zA-Z0-9])[a-zA-Z0-9]+[^a-zA-Z0-9]*$} $text ignore whitespace]} {
  360.         set end [expr [lindex $whitespace 1]+1]
  361.         return [$w index "$cur linestart + $end c"]
  362.     }
  363.     set cur [$w index "$cur linestart -1c"]
  364.     }
  365.     return 1.0
  366. }
  367.  
  368. proc Text_NextWord {w index} {
  369.     set cur $index
  370.     while {[$w compare $cur < end]} {
  371.     set text [$w get $cur "$cur lineend"]
  372.     if {[regexp -indices {[^a-zA-Z0-9]*([a-zA-Z0-9]+)} $text ignore whitespace]} {
  373.         set end [expr [lindex $whitespace 1]+1]
  374.         return [$w index "$cur + $end c"]
  375.     }
  376.     set cur [$w index "$cur lineend +1c"]
  377.     }
  378.     return end
  379. }
  380.  
  381. proc Text_KillSelection { w } {
  382.     global tkPriv
  383.     return [expr ! [catch {
  384.     if {[$w compare sel.first <= insert] &&
  385.         [$w compare sel.last >= insert]} {
  386.         Text_Delete $w sel.first sel.last 1
  387.         $w tag remove sel 0.0 end
  388.     } else {
  389.         error "cursor outside selection"
  390.     }
  391.     }]]
  392. }
  393.  
  394. proc Text_Backspace w {
  395.     if {! [Text_KillSelection $w]} {
  396.     Text_Delete $w insert-1c insert
  397.     }
  398. }
  399.  
  400. proc Text_DelRight w {
  401.     if {! [Text_KillSelection $w]} {
  402.     Text_Delete $w insert
  403.     }
  404. }
  405.  
  406. proc Text_DelWordLeft w {
  407.     if {! [Text_KillSelection $w]} {
  408.     Text_Delete $w [Text_PrevWord $w insert] insert 1
  409.     }
  410. }
  411.  
  412. proc Text_DelWordRight w {
  413.     if {! [Text_KillSelection $w]} {
  414.     Text_Delete $w insert [Text_NextWord $w insert] 1
  415.     }
  416. }
  417.  
  418. proc Text_KillRight w {
  419.     if {! [Text_KillSelection $w]} {
  420.     if {[$w index insert] == [$w index {insert lineend}]} {
  421.         Text_Delete $w insert insert+1c 1
  422.     } else {
  423.         Text_Delete $w insert "insert lineend" 1
  424.     }
  425.     }
  426. }
  427.  
  428. proc Text_KillLeft w {
  429.     if {! [Text_KillSelection $w]} {
  430.     if {[$w index insert] == [$w index {insert linestart}]} {
  431.         Text_Delete $w insert-1c insert 1
  432.     } else {
  433.         Text_Delete $w "insert linestart" insert 1
  434.     }
  435.     }
  436. }
  437.  
  438. # Get the fence (for typescripts) or 1.0.
  439. proc Text_GetFence { w } {
  440.     global TextType
  441.     if ![info exists TextType($w)] {
  442.     set TextType($w) text
  443.     }
  444.     if {$TextType($w) == "typescript"} {
  445.     return [$w index fence]
  446.     } else {
  447.     return 1.0
  448.     }
  449. }
  450.  
  451. proc Text_TransposeChars w {
  452.     if {[$w compare insert >= "[Text_GetFence $w] + 2c"]} {
  453.     set c [$w get insert-1c insert]
  454.     Text_Delete $w insert-1c insert
  455.     Text_Insert $w insert-1c $c
  456.  
  457.     }
  458. }
  459.  
  460. proc Text_TransposeCharsEmacs w {
  461.     if {[$w index insert] == [$w index {insert lineend}]} {
  462.     Text_TransposeChars $w
  463.     } elseif {[$w compare insert >= "[Text_GetFence $w] + 1c"]} {
  464.     set c [$w get insert-1c insert]
  465.     Text_Delete $w insert-1c insert
  466.     Text_Insert $w insert+1c $c
  467.     Text_MoveInsert $w insert+2c
  468.  
  469.     }
  470. }
  471.  
  472. # Swap words on either side of insertion point.
  473. proc Text_TransposeWords w {
  474.     set start1 [Text_PrevWord $w insert]
  475.     set end1   [Text_NextWord $w $start1]
  476.     set end2   [Text_NextWord $w $end1]
  477.     set start2 [Text_PrevWord $w $end2]
  478.     if {[$w compare $end1 > $start2]
  479.     || [$w compare $start1 < [Text_GetFence $w]]} {
  480.     return
  481.     }
  482.     set w1 [$w get $start1 $end1]
  483.     set w2 [$w get $start2 $end2]
  484.     $w mark set twMark $end2
  485.     Text_Delete $w $start2 $end2
  486.     Text_Insert $w $start2 $w1
  487.     Text_Delete $w $start1 $end1
  488.     Text_Insert $w $start1 $w2
  489.     Text_MoveInsert $w twMark
  490. }
  491.  
  492. proc Text_GotoLine { w } {
  493.     set sel [Text_Selection]
  494.     if {[regexp {^[0-9]+$} $sel]} {
  495.     Text_MoveInsert $w $sel.0
  496.     }
  497. }
  498.  
  499. proc Text_SearchForward { w } {
  500.     set sel [string tolower [Text_Selection]]
  501.     if {[string length $sel] == 0} { return }
  502.     set incr 1000
  503.     set len [string length $sel]
  504.     set pos insert+1c
  505.     while {[$w compare $pos < end]} {
  506.     set s [string tolower [$w get $pos "$pos + $len c + $incr c"]]
  507.     set offset [string first $sel $s]
  508.     if {$offset >= 0} {
  509.         Text_MoveInsert $w "$pos + $offset c"
  510.         return
  511.     }
  512.     set pos [$w index "$pos + $incr c"]
  513.     }
  514. }
  515.  
  516. proc Text_SearchBackward { w } {
  517.     set sel [string tolower [Text_Selection]]
  518.     if {[string length $sel] == 0} { return }
  519.     set incr 1000
  520.     set len [string length $sel]
  521.     set pos insert-1c
  522.     while {[$w compare 1.0 < $pos]} {
  523.     set s [string tolower [$w get "$pos - $incr c" "$pos + $len c"]]
  524.     set offset [string last $sel $s]
  525.     if {$offset >= 0} {
  526.         Text_MoveInsert $w "$pos - $incr c + $offset c"
  527.         return
  528.     }
  529.     set pos [$w index "$pos - $incr c"]
  530.     }
  531. }
  532.  
  533. proc Text_SetInsert { w mark } {
  534.     Text_MoveInsert $w $mark
  535.     $w mark set anchor insert
  536.     focus $w
  537. }
  538. proc Text_WordSelect { w mark } {
  539.     global tkPriv
  540.     set tkPriv(selectMode) word
  541.     $w mark set insert "$mark wordstart"
  542.     Text_SelectTo $w insert
  543. }
  544. proc Text_LineSelect { w mark } {
  545.     global tkPriv
  546.     set tkPriv(selectMode) line
  547.     $w mark set insert "$mark linestart"
  548.     Text_SelectTo $w insert
  549. }
  550. proc Text_CutRotate { i } {
  551.     if [catch {cutbuffer rotate $i}] {
  552.     foreach b {1 2 3 4 5 6 7} {
  553.         catch {cutbuffer set $b ""}
  554.     }
  555.     }
  556. }
  557. if {0} {
  558.  
  559. bind Text <1> {
  560.     Text_MoveInsert %W @%x,%y
  561.     %W mark set anchor insert
  562.     if {[lindex [%W config -state] 4] == "normal"} {focus %W}
  563. }
  564. bind Text <Double-1> {
  565.     set tkPriv(selectMode) word
  566.     %W mark set insert "@%x,%y wordstart"
  567.     Text_SelectTo %W insert
  568. }
  569. bind Text <Triple-1> {
  570.     set tkPriv(selectMode) line
  571.     %W mark set insert "@%x,%y linestart"
  572.     Text_SelectTo %W insert
  573. }
  574. bind Text <B1-Motion> {
  575.     Text_SelectTo %W @%x,%y
  576. }
  577. bind Text <ButtonRelease-1> { Text_SelectionEnd %W 1 }
  578. bind Text <2> { Text_Yank %W }
  579.  
  580. bind Text <3> { Text_StartExtend %W @%x,%y }
  581. bind Text <B3-Motion> { Text_SelectTo %W @%x,%y }
  582. bind Text <ButtonRelease-3> { Text_SelectionEnd %W 0 }
  583.  
  584. bind Text <Any-KeyPress> {
  585.     if {"%A" != "" && " " <= "%A" && "%A" <= "~"} {
  586.     Text_KillSelection %W
  587.     Text_Insert %W insert %A
  588.     %W yview -pickplace insert
  589.     }
  590. }
  591. bind Text <Return> {Text_Insert %W insert \n; %W yview -pickplace insert}
  592. bind Text <Delete> {Text_Backspace %W; %W yview -pickplace insert}
  593. bind Text <Control-a> {Text_MoveToBOL %W}
  594. bind Text <Control-b> {Text_MoveInsert %W insert-1c}
  595. bind Text <Control-d> {Text_DelRight %W; %W yview -pickplace insert}
  596. bind Text <Control-e> {Text_MoveInsert %W "insert lineend"}
  597. bind Text <Control-f> {Text_MoveInsert %W insert+1c}
  598. bind Text <Control-h> {Text_Backspace %W; %W yview -pickplace insert}
  599. bind Text <Control-j> {Text_Insert %W insert \n; %W yview -pickplace insert}
  600. bind Text <Control-k> {Text_KillRight %W; %W yview -pickplace insert}
  601. bind Text <Control-m> {Text_Insert %W insert \n; %W yview -pickplace insert}
  602. bind Text <Control-n> {Text_MoveInsert %W insert+1l}
  603. bind Text <Control-o> {
  604.     Text_Insert %W insert \n
  605.     Text_MoveInsert %W insert-1c
  606. }
  607. bind Text <Control-p> { Text_MoveInsert %W insert-1l }
  608. bind Text <Control-r> { Text_SearchBackward %W }
  609. bind Text <Control-s> { Text_SearchForward %W }
  610. bind Text <Control-t> { Text_TransposeChars %W }
  611. bind Text <Control-w> { Text_KillSelection %W }
  612. bind Text <Meta-b> { Text_MoveInsert %W [Text_PrevWord %W insert] }
  613. bind Text <Meta-d> { Text_DelWordRight %W }
  614. bind Text <Meta-f> { Text_MoveInsert %W [Text_NextWord %W insert] }
  615. bind Text <Meta-h> { Text_DelWordLeft %W }
  616. bind Text <Meta-n> { Text_GotoLine %W }
  617. bind Text <Meta-t> { Text_TransposeWords %W }
  618. bind Text <Meta-less> { Text_MoveInsert %W 1.0 }
  619. bind Text <Meta-greater> { Text_MoveInsert %W end }
  620.  
  621. bind Text <Control-y> { Text_Yank %W }
  622. bind Text <Meta-y> { Text_YankPop %W }
  623.  
  624. bind Text <Delete> {Text_Backspace %W; %W yview -pickplace insert}
  625. bind Text <BackSpace> {Text_Backspace %W; %W yview -pickplace insert}
  626. bind Text <Meta-Delete> { Text_DelWordLeft %W }
  627. bind Text <Meta-BackSpace> { Text_DelWordLeft %W }
  628.  
  629. }
  630.  
  631.  
  632.